home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / bytecodes.h < prev    next >
Text File  |  1993-07-12  |  21KB  |  1,028 lines
  1. /* Contains definitions of all the bytecodes I'll use */
  2. /* Warning: This version not unbder RCS! */
  3. #define BC_NOP_CODE        \
  4. /* easy */
  5.  
  6. /* Arg 0: Module, Arg 1: offset */
  7. #define BC_PUSH_GLOBAL_CODE \
  8. {                \
  9.   int i,j;            \
  10.   LispObject tmp;        \
  11.                 \
  12.   read_int_arg(i,pc);        \
  13.   read_int_arg(j,pc);        \
  14.   PUSH_VAL(sp,GLOB_REF(i,j));    \
  15. }
  16.  
  17. #define BC_PUSH_STATIC_CODE \
  18. {                \
  19.   int j;            \
  20.   LispObject tmp;        \
  21.   read_int_arg(j,pc);        \
  22.   PUSH_VAL(sp,vref(this_context,j));    \
  23.   VCHECK(PEEK_VAL(sp));        \
  24. }
  25.  
  26. #define BC_SET_STATIC_CODE     \
  27. {                \
  28.   int j;            \
  29. /**/                \
  30.   read_int_arg(j,pc);        \
  31.   vref(this_context,j)=TOP_VAL(sp);    \
  32. }
  33.  
  34. /* Arg 0: module, Arg 1: offset */
  35. #define BC_SET_GLOBAL_CODE \
  36. {                \
  37.   int i,j;            \
  38.                   \
  39.   read_int_arg(i,pc);        \
  40.   read_int_arg(j,pc);        \
  41.   GLOB_REF(i,j) = TOP_VAL(sp);        \
  42. }
  43.  
  44. #define BC_PUSH_FIXNUM_CODE \
  45. {        \
  46.   int i;    \
  47.   LispObject tmp;    \
  48.   read_int_arg(i,pc);    \
  49.   tmp=allocate_integer(sp+1,i);    \
  50.   PUSH_VAL(sp,tmp);    \
  51. }
  52.  
  53. #define BC_PUSH_SMALL_FIXNUM_CODE \
  54. {            \
  55.   int i;        \
  56.   LispObject tmp;    \
  57. /**/            \
  58.   i=read_byte_arg(i,pc);    \
  59.   tmp=allocate_integer(sp+1,i);    \
  60.   PUSH_VAL(sp,tmp);        \
  61. }
  62.  
  63. #define BC_PUSH_SPECIAL_CODE        \
  64. {                    \
  65.    switch (*(pc++))                \
  66.      {                    \
  67.      case 0:                \
  68.        PUSH_VAL(sp,BCnil);        \
  69.        break;                \
  70.                            \
  71.      case 1:                   \
  72.        PUSH_VAL(sp,BCtrue);        \
  73.        break;                \
  74.     \
  75.      default:                \
  76.        fprintf(stderr,"odd special");   \
  77.        PUSH_VAL(sp,BCnil);        \
  78.        break;                    \
  79.      }                    \
  80. }                    \
  81.  
  82. /* args: n */
  83. #define BC_PUSH_NTH_CODE     \
  84. {                \
  85.   int i;            \
  86.   LispObject tmp;        \
  87.   read_byte_arg(i,pc);        \
  88. /**/                  \
  89.   tmp=NTH_REF(sp,i);        \
  90.   PUSH_VAL(sp,tmp);        \
  91. }
  92.  
  93. #define BC_PUSH_NTH_0_CODE    \
  94. {            \
  95.   LispObject tmp;    \
  96.   /**/            \
  97.   tmp=PEEK_VAL(sp);    \
  98.   PUSH_VAL(sp,tmp);    \
  99. }
  100.  
  101. #define BC_PUSH_NTH_1_CODE    \
  102. {                \
  103.   LispObject tmp;        \
  104.   tmp=NTH_REF(sp,1);        \
  105.   PUSH_VAL(sp,tmp);        \
  106. }
  107.  
  108.  
  109. #define BC_PUSH_NTH_2_CODE    \
  110. {                \
  111.   LispObject tmp;        \
  112.   tmp=NTH_REF(sp,2);        \
  113.   PUSH_VAL(sp,tmp);        \
  114. }
  115.  
  116.  
  117. #define BC_PUSH_NTH_3_CODE    \
  118. {                \
  119.   LispObject tmp;        \
  120.   tmp=NTH_REF(sp,3);        \
  121.   PUSH_VAL(sp,tmp);        \
  122. }
  123.  
  124.  
  125. /* Arg 1: n */
  126. #define BC_SET_NTH_CODE        \
  127. {                \
  128.   int i;            \
  129.                 \
  130.   read_byte_arg(i,pc);        \
  131.                 \
  132.   NTH_REF(sp,i)=PEEK_VAL(sp);    \
  133.   POP_VALS(sp,1);        \
  134.   VCHECK(PEEK_VAL(sp));        \
  135. }
  136.  
  137.  
  138. /* Arg1: dist arg2: keep */
  139.  
  140. #define BC_SLIDE_STACK_CODE    \
  141. {                \
  142.   int depth,keep,n,counter;    \
  143.                   \
  144.   read_byte_arg(depth,pc);        \
  145.   read_byte_arg(keep,pc);        \
  146.   sp-= depth;                \
  147.   n=depth-keep;                \
  148.   for (counter=0; counter<keep;        \
  149.        counter++)            \
  150.    {                    \
  151.      sp++;                \
  152.      *sp= *(sp+n);            \
  153.     }                    \
  154. }
  155.  
  156. #define BC_SLIDE_1_CODE    \
  157. {                \
  158.   int depth;            \
  159.   LispObject tmp;        \
  160. /**/                \
  161.   read_byte_arg(depth,pc);    \
  162.   tmp=PEEK_VAL(sp);        \
  163.   POP_VALS(sp,depth);        \
  164.   PUSH_VAL(sp,tmp);        \
  165. }
  166.  
  167. #define BC_SWAP_CODE        \
  168. {                \
  169.   LispObject tmp;        \
  170.                 \
  171.   tmp= *sp;            \
  172.   *sp = *(sp-1);        \
  173.   *(sp-1) = tmp;        \
  174. }
  175.  
  176.  
  177. #define BC_DROP_CODE        \
  178. {                \
  179.   int i;            \
  180.                 \
  181.   read_byte_arg(i,pc);        \
  182.   POP_VALS(sp,i);        \
  183. }
  184.  
  185. #define BC_DROP_1_CODE    \
  186. {            \
  187.   POP_VALS(sp,1);    \
  188. }
  189.  
  190. /* arg1: depth arg2: dist */
  191. #define BC_ENV_REF_CODE        \
  192. {                \
  193.   int i,j,counter;        \
  194.   LispObject env=PEEK_VAL(sp);    \
  195.                 \
  196.   BC_CHECK(is_vector,env);    \
  197.   read_byte_arg(i,pc);        \
  198.   read_byte_arg(j,pc);        \
  199.   ENV_REF(env,env,i,j);        \
  200.   SHOVE_VAL(sp,env);        \
  201.   VCHECK(PEEK_VAL(sp));        \
  202. }
  203.  
  204. /* arg1: depth arg2: dist */
  205. #define BC_SET_ENV_CODE        \
  206. {                \
  207.   int i,j,counter;        \
  208.   LispObject env;        \
  209.   LispObject val;        \
  210.     /**/            \
  211.   val=TOP_VAL(sp);        \
  212.   env=PEEK_VAL(sp);        \
  213.   BC_CHECK(is_vector,env);    \
  214.                 \
  215.   read_byte_arg(i,pc);        \
  216.   read_byte_arg(j,pc);        \
  217.   SET_ENV_REF(env,i,j,val);    \
  218. }
  219.  
  220. /* Arg1: Depth */
  221. #define BC_POP_ENV_CODE        \
  222. {                \
  223.   int i,counter;        \
  224.   LispObject env=PEEK_VAL(sp);    \
  225.                 \
  226.   read_byte_arg(i,pc);        \
  227.   ENV_NTH(env,i);        \
  228.   SHOVE_VAL(sp,env);        \
  229.   VCHECK(PEEK_VAL(sp));        \
  230. }
  231.  
  232.  
  233. #define BC_MAKE_ENV_CODE    \
  234. {                \
  235.   int i;            \
  236.                 \
  237.   read_byte_arg(i,pc);        \
  238.   MAKE_ENV(sp,i);        \
  239.   VCHECK(PEEK_VAL(sp));        \
  240.   GC_RESTORE_GLOBALS;        \
  241. }
  242.  
  243. /* Object reference */
  244. /* arg: n */
  245. #define BC_VREF_CODE        \
  246. {                \
  247.   LispObject tmp=TOP_VAL(sp);    \
  248. /**/                \
  249. BC_BUG(                \
  250.   if (intval(tmp) > PEEK_VAL(sp)->VECTOR.length)             \
  251.     CallError(sp+2,"duff vector-ref",PEEK_VAL(sp),NONCONTINUABLE);    \
  252.        )                \
  253.   SHOVE_VAL(sp,vref(PEEK_VAL(sp),    \
  254.             intval(tmp)));    \
  255.   VCHECK(PEEK_VAL(sp));    \
  256. }
  257. #if 0
  258.   if (intval(tmp) > PEEK_VAL(sp)->VECTOR.length)
  259.     CallError(sp+2,"duff vector-ref",PEEK_VAL(sp),NONCONTINUABLE);
  260. #endif
  261. /* arg: n */
  262. #define BC_SET_VREF_CODE        \
  263. {                    \
  264.   LispObject val=TOP_VAL(sp);        \
  265.   LispObject loc;            \
  266.   loc=TOP_VAL(sp);              \
  267. /**/                    \
  268.   vref(PEEK_VAL(sp),intval(loc))=val;    \
  269.   SHOVE_VAL(sp,val);            \
  270. }
  271.  
  272.  
  273. #define BC_SLOT_REF_CODE           \
  274. {                    \
  275.   LispObject obj=PEEK_VAL(sp);        \
  276.   int i;                \
  277. /**/                    \
  278.   read_byte_arg(i,pc);            \
  279.   SHOVE_VAL(sp,slotref(obj,i));    \
  280.   VCHECK(PEEK_VAL(sp));        \
  281. }
  282.  
  283. #define BC_SLOT_REF_0_CODE    \
  284. {                \
  285.   LispObject obj;        \
  286.   obj=PEEK_VAL(sp);        \
  287.   SHOVE_VAL(sp,slotref(obj,0));    \
  288. }
  289.  
  290. #define BC_SLOT_REF_1_CODE    \
  291. {                \
  292.   LispObject obj;        \
  293. /**/                \
  294.   obj=PEEK_VAL(sp);        \
  295.   SHOVE_VAL(sp,slotref(obj,1));    \
  296. }
  297.  
  298. #define BC_SET_SLOT_CODE         \
  299. {                    \
  300.   LispObject val;            \
  301.   LispObject obj;            \
  302.   int i;                \
  303. /**/                    \
  304.   val=TOP_VAL(sp);            \
  305.   obj=PEEK_VAL(sp);            \
  306. /**/                    \
  307.   read_byte_arg(i,pc);            \
  308.   slotref(obj,i)=val;            \
  309.   SHOVE_VAL(sp,val);            \
  310. }
  311.  
  312. /* set-slot 1 is called lots. set-slot 0 isn't. */
  313. #define BC_SET_SLOT_1_CODE        \
  314. {                    \
  315.   LispObject val;            \
  316.   LispObject obj;            \
  317. /**/                    \
  318.   val=TOP_VAL(sp);            \
  319.   obj=PEEK_VAL(sp);            \
  320. /**/                    \
  321.   slotref(obj,1)=val;            \
  322.   SHOVE_VAL(sp,val);            \
  323. }
  324.  
  325. #define BC_SET_TYPE_CODE               \
  326. {                           \
  327.   LispObject type;            \
  328.   type=TOP_VAL(sp);            \
  329. /**/                      \
  330.   lval_typeof(PEEK_VAL(sp))=intval(type);    \
  331. }
  332.  
  333. #define BC_BRANCH_CODE        \
  334. {                \
  335.   int i;            \
  336.   bytecode *opc=pc;        \
  337.                   \
  338.   read_int_arg(i,pc);        \
  339.   pc=ADJUST_PC(opc,i);        \
  340. }
  341.  
  342. #define BC_BRANCH_NIL_CODE    \
  343. {                \
  344.   int i;            \
  345.                 \
  346.   if (TOP_VAL(sp)==BCnil)    \
  347.     {                \
  348.       bytecode *opc=pc;        \
  349.       read_int_arg(i,pc);    \
  350.       pc=ADJUST_PC(opc,i);    \
  351.     }                \
  352.   else                \
  353.     skip_int_arg(pc);        \
  354. }
  355.  
  356. #define BC_APPLY_ARGS_CODE    \
  357. {            \
  358.   LispObject args,fn;    \
  359.   nargs=0;        \
  360.     /**/        \
  361.   args=TOP_VAL(sp);    \
  362.   fn=TOP_VAL(sp);    \
  363.   SHOVE_VAL(sp,fn);    \
  364.   while (args!=nil)    \
  365.     {            \
  366.       PUSH_VAL(sp,CAR(args));        \
  367.       args=CDR(args);    \
  368.       nargs++;        \
  369.     }            \
  370.       /**/        \
  371.   PUSH_VAL(sp,fn);    \
  372.   goto apply_label;    \
  373. }
  374.  
  375. /* The tricky ones.... */
  376. /* stack is: fn <lab> a0 a1....an fn */
  377. /* return is: val */
  378.  
  379. #define BC_APPLY_ANY_CODE        \
  380. {                    \
  381.   int abs_args,real_args;        \
  382.   LispObject fn,tmp;            \
  383.   LispObject *arg_start;        \
  384.   read_sign_arg(nargs,pc);        \
  385. apply_label:                \
  386.   abs_args=nargs<0? -nargs: nargs;    \
  387.   fn=TOP_VAL(sp);            \
  388.   switch(typeof(fn))            \
  389.     {                    \
  390.     case TYPE_GENERIC:                \
  391.       {                    \
  392.     LispObject ptr,*walker,fast,slow;\
  393.     LispObject meths;        \
  394.     int count,depth;        \
  395.                     \
  396.     arg_start=(sp-nargs)+1;        \
  397.     BC_BUG( ((int) *(arg_start-3) &1) ? 0 : CallError(stacktop,"Impossible return", BCnil,NONCONTINUABLE)); \
  398.     fast=(generic_fast_method_cache(fn));     \
  399.     slow=generic_slow_method_cache(fn);        \
  400.     depth=intval(generic_discrimination_depth(fn)); \
  401.     /* is there a cache ? */        \
  402.     if (fast!=BCnil)                \
  403.       {                    \
  404.         /** Method lookup **/        \
  405.         walker=arg_start;            \
  406.         ptr=CAR(fast);            \
  407.         while (ptr!=BCnil && CAR(ptr)==classof(*(walker)))    \
  408.           {                    \
  409.         ptr=CDR(ptr);                \
  410.         walker++;                 \
  411.           }                        \
  412.                             \
  413.         if (ptr==BCnil)                \
  414.           {                        \
  415.         meths=CDR(fast);            \
  416.         goto call_method;            \
  417.           }                        \
  418.         /* then the slow cache */            \
  419.         ptr=slow;                    \
  420.         walker=arg_start;                \
  421.         count=0;                    \
  422.                             \
  423.         while(ptr!=BCnil && count<depth)        \
  424.           {                        \
  425.         if (CAR(CAR(ptr))==classof(*(walker)))    \
  426.           {        /* move down 1 */    \
  427.             ptr=CDR(CAR(ptr));            \
  428.             walker++;                \
  429.             count++;                \
  430.           }                    \
  431.         else                    \
  432.           ptr=CDR(ptr);                \
  433.           }                        \
  434.                             \
  435.         if (count==depth)                \
  436.           {                        \
  437.         generic_fast_method_cache(fn)=ptr;    \
  438.         meths=CDR(ptr);                \
  439.         goto call_method;            \
  440.           }                        \
  441.         /* not in slow cache */            \
  442.       }                        \
  443.     /* no cache */                    \
  444.       {                        \
  445.       LispObject res,args;                \
  446.       PUSH_VAL(sp,fn);                \
  447.       args=allocate_n_conses(sp+1,nargs);        \
  448.       ptr=args;                    \
  449.       walker=arg_start;                \
  450.       count=0;                    \
  451.       while (count<nargs)                \
  452.         {                        \
  453.           CAR(ptr)= *walker;            \
  454.           ptr=CDR(ptr); ++walker; ++count;        \
  455.         }                        \
  456.       fn=PEEK_VAL(sp);                \
  457.         /* Call the methods...*/            \
  458.       SET_STACK(sp,arg_start);            \
  459.           *sp=fn; *(sp+1)=args;    sp++;        \
  460.       GC_RESTORE_GLOBALS;            \
  461.           fn=GLOBAL_REF(Generic_Lookup_Fn);        \
  462.           APPLY_BVF(fn);                \
  463.       break;            \
  464.       }                        \
  465.       call_method:                    \
  466.     /* method calling code */            \
  467.       CALL_METHOD_LIST(arg_start,meths,nargs);    \
  468.       }                            \
  469.       break;                        \
  470.     case TYPE_B_FUNCTION:                    \
  471.     case TYPE_B_MACRO:                    \
  472.       {                            \
  473.     int real_args=                    \
  474.       intval(bytefunction_nargs(fn));    \
  475.     if (nargs>=0 && real_args<0)            \
  476.       {                        \
  477.         int j=nargs+1;                \
  478.         int k= -real_args;                \
  479.         LispObject *cons_sp;            \
  480.         *(++sp)=BCnil;                \
  481.             cons_sp=sp+2;                \
  482.         /*loop til we have lost enough*/        \
  483.         while (k!=j)                \
  484.           {                        \
  485.         LispObject tmp;            \
  486.         *(sp+1)=fn;            \
  487.         sp--;         \
  488.                 *cons_sp=*sp;                    \
  489.         *(cons_sp+1)=*(sp+1);                \
  490.         tmp=Fn_cons(cons_sp);                \
  491.         *sp=tmp;                     \
  492.         cons_sp--;                    \
  493.         fn=*(sp+2);                    \
  494.         j--;                        \
  495.           }                        \
  496.         GC_RESTORE_GLOBALS;                \
  497.       }                        \
  498.     APPLY_BVF(fn);                \
  499.     }                        \
  500.        break;                        \
  501.                                   \
  502.     default:                        \
  503.       {                            \
  504.     LispObject res;                    \
  505.     arg_start=sp-abs_args;            \
  506.     BC_BUG( ((int) *(arg_start-2)) &1 ? 0 : CallError(stacktop,"Impossible return", BCnil,NONCONTINUABLE)); \
  507.     res=module_apply_args(arg_start+1,nargs,fn);    \
  508.     GC_RESTORE_GLOBALS;                \
  509.     SET_STACK(sp,arg_start-1);            \
  510.     pc=SET_PC(sp);                      \
  511.     PUSH_VAL(sp,res);                \
  512.       }                            \
  513.       break;                        \
  514.     }                            \
  515. }
  516.  
  517. #define BC_APPLY_BVF_CODE    \
  518. {                    \
  519.   LispObject fn;            \
  520.   int nargs;                \
  521.   read_byte_arg(nargs,pc);    \
  522. /**/                \
  523.   fn=TOP_VAL(sp);        \
  524.   APPLY_BVF(fn);        \
  525. }
  526.  
  527. #define BC_APPLY_CFN_CODE    \
  528. {                           \
  529.   LispObject fn,ret;            \
  530.   int args;                \
  531.     /**/                \
  532.   fn=TOP_VAL(sp);            \
  533.   read_sign_arg(args,pc);        \
  534.   BC_BUG(fprintf(stderr,"Apply %s %d\n", \
  535.          stringof(fn->C_FUNCTION.name->SYMBOL.pname), args)); \
  536.     /**/                \
  537.   if (args!=fn->C_FUNCTION.argtype)    \
  538.     exit(0);                \
  539.   args=(args > 0 ? args : -args);    \
  540.   ret=(fn->C_FUNCTION.func)(sp-args+1);    \
  541.   GC_RESTORE_GLOBALS;            \
  542.     /**/                \
  543.   POP_VALS(sp,args+1);            \
  544.   pc=SET_PC(sp);            \
  545.   PUSH_VAL(sp,ret);            \
  546. }
  547.  
  548. #define BC_APPLY_CFN2_CODE        \
  549. {                     \
  550.   LispObject tmp;            \
  551.   int args,absargs;            \
  552.                      \
  553.   read_sign_arg(args,pc);        \
  554.   absargs=(args > 0 ? args : -args);    \
  555.   tmp=NTH_REF(sp,absargs);        \
  556.                      \
  557.   BC_BUG(fprintf(stderr,"Apply %s %d\n",\
  558.          stringof(tmp->C_FUNCTION.name->SYMBOL.pname), args)); \
  559.                       \
  560.   if (args!=tmp->C_FUNCTION.argtype)    \
  561.     exit(0);                \
  562.                       \
  563.   tmp=(tmp->C_FUNCTION.func)(sp-absargs+1);    \
  564.   GC_RESTORE_GLOBALS;            \
  565.   POP_VALS(sp,absargs+1);        \
  566.   PUSH_VAL(sp,tmp);            \
  567. }
  568.  
  569. #define BC_APPLY_METHODS_CODE    \
  570. {                    \
  571.   LispObject ml;            \
  572.   int args;                \
  573.   LispObject *base;            \
  574.                       \
  575.   read_byte_arg(args,pc);        \
  576.   base=sp-args;                \
  577.                       \
  578.   ml=TOP_VAL(sp);            \
  579.                     \
  580.   CALL_METHOD_LIST(base,ml,args);    \
  581. }
  582.  
  583. #define BC_APPLY_METHOD_LIST_CODE     \
  584. {                    \
  585.   LispObject tmp,meths,*base;        \
  586.   int n=0;                \
  587.                     \
  588.   meths=TOP_VAL(sp);            \
  589.   tmp=TOP_VAL(sp);            \
  590.                     \
  591.   base=sp+1;                \
  592.   while(tmp!=BCnil)            \
  593.     {                    \
  594.       PUSH_VAL(sp,CAR(tmp));        \
  595.       tmp=CDR(tmp);            \
  596.       n++;                \
  597.     }                    \
  598.                       \
  599.   CALL_METHOD_LIST(base,meths,n);    \
  600. }
  601.  
  602. #define BC_PUSH_LABEL_CODE    \
  603. { /* istream should hold an offset */    \
  604.   bytecode *new_pc;                \
  605.   LispObject xx;            \
  606.   int i;                \
  607.   bytecode *opc=pc;            \
  608. /**/                    \
  609.   read_int_arg(i,pc);            \
  610.   new_pc=ADJUST_PC(opc,i);        \
  611.   BC_BUG( if (GLOBAL_REF(BC_Debug)==BCtrue) fprintf(stderr,"Push lab: %x",new_pc));    \
  612.   STASH_PC(sp,new_pc);        \
  613. }
  614.  
  615. /* stack is: fn <addr> retval        */
  616. #define BC_RETURN_CODE    /* and back */    \
  617. {                    \
  618.   LispObject tmp=TOP_VAL(sp);        \
  619. /**/                    \
  620.   HANDLE_SIGNALS();            \
  621.   VCHECK(tmp);                \
  622.   POP_VALS(sp,1);                     \
  623.   pc=SET_PC(sp);    \
  624.   PUSH_VAL(sp,tmp);            \
  625. }
  626.  
  627. /** External environment */
  628. #define BC_CONTEXT_CODE    \
  629. {            \
  630.   PUSH_VAL(sp,this_context);        \
  631. }            \
  632.  
  633. #define BC_EXIT_CODE                 \
  634. {                        \
  635.   BC_BUG( if (GLOBAL_REF(BC_Debug)==BCtrue) fprintf(stderr,"{exiting: %x}",sp));    \
  636.   return (TOP_VAL(sp));                \
  637. }
  638.  
  639. /* allocation */
  640.  
  641. #define BC_CONS_CODE    \
  642. {            \
  643.   LispObject tmp;    \
  644. /**/            \
  645.   tmp=Fn_cons(sp-1);    \
  646.   POP_VALS(sp,1);    \
  647.   SHOVE_VAL(sp,tmp);        \
  648.   GC_RESTORE_GLOBALS;    \
  649. }
  650.  
  651. #define BC_NULLP_CODE    \
  652. {            \
  653.   if (PEEK_VAL(sp)==BCnil)\
  654.     SHOVE_VAL(sp,BCtrue);    \
  655.   else                \
  656.     SHOVE_VAL(sp,BCnil);    \
  657. }
  658.  
  659. #define BC_EQP_CODE    \
  660. {            \
  661.   LispObject tmp;    \
  662. /**/            \
  663.   tmp=TOP_VAL(sp);    \
  664. /**/            \
  665.   if (PEEK_VAL(sp)==tmp) \
  666.     SHOVE_VAL(sp,BCtrue); \
  667.   else             \
  668.     SHOVE_VAL(sp,BCnil); \
  669. }
  670.  
  671. #define BC_CONSP_CODE    \
  672. {            \
  673.   LispObject tmp;    \
  674.   tmp=PEEK_VAL(sp);    \
  675. /**/            \
  676.   if (is_cons(tmp))    \
  677.     SHOVE_VAL(sp,BCtrue);    \
  678.   else                \
  679.     SHOVE_VAL(sp,BCnil);    \
  680. }
  681.  
  682.  
  683. #define BC_ALLOC_CLOSURE_CODE         \
  684. { /* expect <label> <env> on stack, nargs in stream */              \
  685.   LispObject env,ctxt;                              \
  686.   LispObject tmp,tmp2;                              \
  687.   bytecode *start;                              \
  688.   int nargs;                                  \
  689.   int offset;                              \
  690.   /* ought to be a long */                          \
  691.   read_sign_arg(nargs,pc);                          \
  692.                                         \
  693.   tmp=allocate_instance(sp+1,                          \
  694.             ByteFunction);          \
  695.   lval_typeof(tmp)=TYPE_B_FUNCTION;                      \
  696.   bytefunction_env(tmp)=TOP_VAL(sp);                      \
  697.   /* Grab context+offset from stack...*/                  \
  698.   UNSTASH_PC(sp,ctxt,offset);                        \
  699.   PUSH_VAL(sp,tmp);                        \
  700.   bytefunction_globals(tmp)=ctxt;            \
  701.   tmp2=allocate_integer(sp+1,offset);            \
  702.   tmp=PEEK_VAL(sp);                    \
  703.   bytefunction_offset(tmp)=tmp2;            \
  704.   tmp2=allocate_integer(sp+1,nargs);            \
  705.   tmp=PEEK_VAL(sp);                    \
  706.   bytefunction_nargs(tmp)=tmp2;                \
  707.   GC_RESTORE_GLOBALS;                    \
  708. }
  709.  
  710. #define BC_ALLOC_EXT_CLOSURE_CODE         \
  711. { /* expect <label> <env> <info> on stack, nargs in stream */              \
  712.   LispObject env,ctxt;                              \
  713.   LispObject tmp,tmp2;                              \
  714.   bytecode *start;                              \
  715.   int nargs;                                  \
  716.   int offset;                              \
  717.   /* ought to be a long */                          \
  718.   read_sign_arg(nargs,pc);                          \
  719.                                         \
  720.   tmp=allocate_instance(sp+1,                          \
  721.             ExtByteFunction);          \
  722.   lval_typeof(tmp)=TYPE_B_FUNCTION;                      \
  723.   extbytefunction_info(tmp)=TOP_VAL(sp);                \
  724.   bytefunction_env(tmp)=TOP_VAL(sp);                      \
  725.   /* Grab context+offset from stack...*/                  \
  726.   UNSTASH_PC(sp,ctxt,offset);                        \
  727.   PUSH_VAL(sp,tmp);                        \
  728.   bytefunction_globals(tmp)=ctxt;            \
  729.   tmp2=allocate_integer(sp+1,offset);            \
  730.   tmp=PEEK_VAL(sp);                    \
  731.   bytefunction_offset(tmp)=tmp2;            \
  732.   tmp2=allocate_integer(sp+1,nargs);            \
  733.   tmp=PEEK_VAL(sp);                    \
  734.   bytefunction_nargs(tmp)=tmp2;                \
  735.   GC_RESTORE_GLOBALS;                    \
  736. }
  737.  
  738. /* Common functions --- assq, memq, scanq */
  739. #define BC_ASSQ_CODE    \
  740. {                    \
  741.   LispObject ob,lst,val;    \
  742.                 \
  743.   lst=TOP_VAL(sp);        \
  744.   ob=PEEK_VAL(sp);        \
  745.   val=BCnil;            \
  746.                 \
  747.   while (lst!=BCnil)        \
  748.     {                \
  749.       if (CAR(CAR(lst))==ob)    \
  750.     {            \
  751.       val=CAR(lst);        \
  752.       break;        \
  753.     }            \
  754.       lst=CDR(lst);        \
  755.     }                \
  756.                   \
  757.   SHOVE_VAL(sp,val);        \
  758. }
  759.  
  760. #define BC_MEMQ_CODE        \
  761. {                \
  762.   LispObject ob,lst,val;    \
  763.                   \
  764.   lst=TOP_VAL(sp);        \
  765.   ob=PEEK_VAL(sp);        \
  766.   val=BCnil;            \
  767.                 \
  768.   while (lst!=BCnil)        \
  769.     {                \
  770.       if (CAR(lst)==ob)        \
  771.     {            \
  772.       val=lst;        \
  773.       break;        \
  774.     }            \
  775.       lst=CDR(lst);        \
  776.     }                \
  777.   SHOVE_VAL(sp,val);        \
  778. }
  779.  
  780. /* no check for unbalanced lists, etc */
  781. #define BC_SCANQ_CODE             \
  782. {                    \
  783.   LispObject ob,lst,fn;            \
  784.   extern LispObject unbound;        \
  785.   lst=TOP_VAL(sp);            \
  786.   ob=PEEK_VAL(sp);            \
  787.                     \
  788.   while (lst!=BCnil && CAR(lst)!=ob)    \
  789.     {                    \
  790.           lst=CDR(CDR(lst));        \
  791.     }                    \
  792.   if (lst==BCnil)            \
  793.     SHOVE_VAL(sp,unbound);        \
  794.   else                    \
  795.     SHOVE_VAL(sp,CAR(CDR(lst)));    \
  796. }
  797.  
  798. #define APPLY_BVF(fn)    \
  799.   pc=BF2PC(fn);            \
  800.   PUSH_VAL(sp,bytefunction_env(fn));
  801.  
  802. #ifdef WITH_SPECIAL_METHOD
  803. #define ON_SPECIAL_METHOD(x) x
  804. #else
  805. #define ON_SPECIAL_METHOD(x)
  806. #endif
  807.  
  808. /* Inserted by other macros */
  809. /* bungs return onto stack */
  810. #define CALL_METHOD_LIST(base,ml,nargs)    \
  811. {                    \
  812.   LispObject mf,res;                \
  813.   short type;                     \
  814.   mf=method_function(CAR(ml));            \
  815.   type=typeof(mf);                \
  816.   if (type==TYPE_B_FUNCTION)            \
  817.     {                        \
  818.       SET_NTH_REF(base,1,ml);            \
  819.       APPLY_BVF(mf);                \
  820.       break;                    \
  821.     }                        \
  822.   if (type==TYPE_C_FUNCTION)            \
  823.     res=(mf->C_FUNCTION.func)(base);        \
  824.   else                        \
  825.     {                        \
  826.       if (type==TYPE_I_FUNCTION)        \
  827.     res = call_method(base,nargs,ml);           \
  828.       else                        \
  829.     CallError(base,"Illegal type",ml,NONCONTINUABLE); \
  830.     }                        \
  831.   GC_RESTORE_GLOBALS;                \
  832.   SET_STACK(sp,base-2);                \
  833.   pc=SET_PC(sp);              \
  834.   PUSH_VAL(sp,res);            \
  835.   break;                \
  836. }
  837.  
  838. #define HANDLE_SIGNALS()                        \
  839. {                                \
  840.   if (SYSTEM_GLOBAL_VALUE(system_interrupt_flag))            \
  841.     {                /* fix up return address */    \
  842.       int flags=SYSTEM_GLOBAL_VALUE(system_interrupt_flag);        \
  843.       LispObject i;                        \
  844.       i=allocate_integer(sp+1,SYSTEM_GLOBAL_VALUE(system_interrupt_flag));            \
  845.       SYSTEM_GLOBAL_VALUE(system_interrupt_flag)=0;            \
  846.       STASH_PC(sp,pc-1);/* back here*/                        \
  847.       PUSH_VAL(sp,GLOBAL_REF(Signal_Thread_Fn));        /* fn called */            \
  848.       PUSH_VAL(sp,GLOBAL_REF(Interpreter_Thread));            \
  849.       PUSH_VAL(sp,i);            \
  850.       APPLY_BVF(GLOBAL_REF(Signal_Thread_Fn));        \
  851.       break;                            \
  852.     }                                \
  853. }
  854. #ifdef nope /* Mon Nov  2 16:10:20 1992 */
  855. /**/
  856. /**/    ON_SPECIAL_METHOD(                            \
  857. /**/    case TYPE_SPECIAL_METHOD:                    \
  858. /**/      {                                \
  859. /**/        LispObject res;                        \
  860. /**/        BC_METHOD_SWITCH(sp,intval(special_method_id(mf)));        \
  861. /**/        mf=PEEK_VAL(sp);                        \
  862. /**/        SET_STACK(sp,base-1);                    \
  863. /**/        POP_VALS(sp,1);                    \
  864. /**/        pc=SET_PC(sp);              \
  865. /**/        PUSH_VAL(sp,mf);                        \
  866. /**/      }                                \
  867. /**/      break;                            \
  868. /**/        )
  869. #endif /* nope Mon Nov  2 16:10:20 1992 */
  870.  
  871. #define BC_METHOD_SWITCH(stack,id)    \
  872. {                    \
  873.   LispObject arg1,arg2,res;        \
  874.   switch (id)                \
  875.     {                    \
  876.     case METHOD_INT_ADD:        \
  877.       {                    \
  878.     int i;                \
  879.     arg1=TOP_VAL(stack);        \
  880.     arg2=PEEK_VAL(stack);        \
  881.                     \
  882.     i=intval(arg1)+intval(arg2);    \
  883.     res=allocate_integer(stack,i);    \
  884.     SHOVE_VAL(stack,res);        \
  885.       }                    \
  886.       break;                \
  887.                     \
  888.     case METHOD_INT_DIFF:        \
  889.       {                    \
  890.     int i;                \
  891.     arg2=TOP_VAL(stack);        \
  892.     arg1=PEEK_VAL(stack);        \
  893.                     \
  894.     i=intval(arg1)-intval(arg2);    \
  895.     res=allocate_integer(stack,i);    \
  896.     SHOVE_VAL(stack,res);        \
  897.       }                    \
  898.       break;                \
  899.     case METHOD_INT_MULT:        \
  900.       {                    \
  901.     int i;                \
  902.     arg2=TOP_VAL(stack);        \
  903.     arg1=PEEK_VAL(stack);        \
  904.                     \
  905.     i=intval(arg1)*intval(arg2);    \
  906.     res=allocate_integer(stack,i);    \
  907.     SHOVE_VAL(stack,res);        \
  908.       }                    \
  909.       break;                \
  910.                     \
  911.     case METHOD_INT_DIV:        \
  912.       {                    \
  913.     int i;                \
  914.     arg2=TOP_VAL(stack);        \
  915.     arg1=PEEK_VAL(stack);        \
  916.                     \
  917.     i=intval(arg1)/intval(arg2);    \
  918.     res=allocate_integer(stack,i);    \
  919.     SHOVE_VAL(stack,res);        \
  920.       }                    \
  921.       break;                \
  922.                           \
  923.     case METHOD_INT_EQUAL:        \
  924.       {                    \
  925.     int i;                \
  926.     arg2=TOP_VAL(stack);        \
  927.     arg1=PEEK_VAL(stack);        \
  928.                     \
  929.     if (intval(arg1)==intval(arg2))    \
  930.       SHOVE_VAL(stack,lisptrue);    \
  931.     else                \
  932.       SHOVE_VAL(stack,BCnil);        \
  933.       }                    \
  934.       break;                \
  935.                     \
  936.     case METHOD_SYMBOL_EQUAL:        \
  937.       {                    \
  938.     int i;                \
  939.     arg2=TOP_VAL(stack);        \
  940.     arg1=PEEK_VAL(stack);        \
  941.                     \
  942.     if ((arg1)==(arg2))        \
  943.       SHOVE_VAL(stack,lisptrue);    \
  944.     else                \
  945.       SHOVE_VAL(stack,BCnil);        \
  946.       }                    \
  947.       break;                \
  948.                           \
  949.     case METHOD_STREAM_STRING_WRITE:    \
  950.       break;                \
  951.                     \
  952.     case METHOD_STREAM_READ:        \
  953.       break;                \
  954.                     \
  955.     case METHOD_SLOT_REF_0:        \
  956.       {                    \
  957.     arg1=PEEK_VAL(stack);        \
  958.     SHOVE_VAL(stack,slotref(arg1,0)); \
  959.       }                      \
  960.       break;                  \
  961.                       \
  962.     case METHOD_SLOT_REF_1:          \
  963.       {                      \
  964.     arg1=PEEK_VAL(stack);          \
  965.     SHOVE_VAL(stack,slotref(arg1,1)); \
  966.       }                      \
  967.       break;                  \
  968.                       \
  969.     case METHOD_SLOT_REF_2:          \
  970.       {                      \
  971.     arg1=PEEK_VAL(stack);          \
  972.     SHOVE_VAL(stack,slotref(arg1,2)); \
  973.       }                      \
  974.       break;                  \
  975.                       \
  976.     case METHOD_SLOT_REF_3:          \
  977.       {                      \
  978.     arg1=PEEK_VAL(stack);          \
  979.     SHOVE_VAL(stack,slotref(arg1,3)); \
  980.       }                      \
  981.       break;                  \
  982.                       \
  983.     case METHOD_SLOT_SET_0:          \
  984.       {                      \
  985.     arg2=TOP_VAL(stack);          \
  986.     arg1=PEEK_VAL(stack);          \
  987.                       \
  988.     slotref(arg1,0)=arg2;          \
  989.     SHOVE_VAL(stack,arg2);          \
  990.       }                      \
  991.       break;                  \
  992.                       \
  993.     case METHOD_SLOT_SET_1:          \
  994.       {                      \
  995.     arg2=TOP_VAL(stack);          \
  996.     arg1=PEEK_VAL(stack);          \
  997.                       \
  998.     slotref(arg1,1)=arg2;          \
  999.     SHOVE_VAL(stack,arg2);          \
  1000.       }                      \
  1001.       break;                  \
  1002.                       \
  1003.     case METHOD_SLOT_SET_2:          \
  1004.       {                      \
  1005.     arg2=TOP_VAL(stack);          \
  1006.     arg1=PEEK_VAL(stack);          \
  1007.                       \
  1008.     slotref(arg1,2)=arg2;          \
  1009.     SHOVE_VAL(stack,arg2);          \
  1010.       }                      \
  1011.       break;                  \
  1012.                       \
  1013.     case METHOD_SLOT_SET_3:          \
  1014.       {                      \
  1015.     arg2=TOP_VAL(stack);          \
  1016.     arg1=PEEK_VAL(stack);          \
  1017.                       \
  1018.     slotref(arg1,3)=arg2;          \
  1019.     SHOVE_VAL(stack,arg2);          \
  1020.       }                      \
  1021.       break;                  \
  1022.                             \
  1023.     }                      \
  1024. }
  1025.  
  1026.  
  1027.  
  1028.